home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / HASHING < prev    next >
Encoding:
Text File  |  1992-01-22  |  14.6 KB  |  674 lines
  1. \ Hash Forth Dictionary to speed compilation.
  2. \
  3. \ Hashing converts a name to a fairly unique
  4. \ number.  This number is used as an index into
  5. \ a hash table containing NFAs.  This is faster
  6. \ than doing a linear search through the linked
  7. \ fields of a normal forth dictionary.
  8. \
  9. \ Hashing can be turned on or off with HASH.ON
  10. \ or HASH.OFF .
  11. \
  12. \ Author: Phil Burk
  13. \ Copyright 1987 Phil Burk
  14.  
  15. \ MOD: mdh 06/15/88 rewrote 'SAVE-FORTH', implemented 'HASH.COLD'
  16. \ MOD: PLB 08/08/88 Fix Increment=0 bug in HASH.SEARCH.LL
  17. \ MOD: mdh 08/28/88 added ASMHASH;
  18. \ MOD: PLB 9/9/88
  19. \ MOD: PLB 11/15/88 Removed FULL message. Added REALLOCATE msg.
  20. \ MOD: PLB 12/10/88 Added proper SMUDGE and UNSMUDGE
  21. \ MOD: PLB 1/11/89 Don't add to hash table if smudged.
  22. \      Check for vocabulary collisions.
  23. \ MOD: MDH 1/17/89 Add include? for ASM for builds with no modules
  24. \ MOD: MDH 1/22/89 Add flushemit after Rehashing...
  25. \ MOD: PLB 2/23/89 Move HASH.NEW.VOC call after HASH.EXPAND to
  26. \      avoid 1/2048 chance of recursion in a redefinition.
  27. \ 00001 PLB 11/27/91 Fixed ASM syntax, thanks to Jerry Kallaus
  28. \ 00002 mdh 15-jan-92 added .need
  29.  
  30. include? ASM jf:Forward-ASM
  31.  
  32. ANEW TASK-HASHING
  33. decimal
  34.  
  35. defer HASH-OLD-:CREATE
  36. defer HASH-OLD-FIND
  37. defer HASH-OLD-SMUDGE
  38. defer HASH-OLD-UNSMUDGE
  39.  
  40. variable HASH-TABLE-PTR  \ hold address of table
  41. variable HASH-TABLE-SIZE \ maximum number of entries
  42. variable HASH-MANY       \ current number of entries
  43. variable HASH-DISPLACED  \ bumped word for smudge
  44. .need HASH-#K  \ 00002
  45. variable HASH-#K         \ initial hash table size
  46. .THEN
  47. variable HASH-VOC-OFFSET
  48. variable HASH-#COLLISIONS
  49. variable HASH-FOUND?
  50. variable HASH-STOPPED
  51. variable HASH-REDEF      \ Set if word is overwritten.
  52.  
  53. : .VAR ( addr -- , print nicely )
  54.     BL 16 emit-to-column ? cr
  55. ;
  56.  
  57. : HASH.DUMP  ( -- ) cr
  58.     ." Address = " hash-table-ptr .var
  59.     ." Maxentries = " hash-table-size .var
  60.     ." Many = " hash-many .var
  61.     ." Hash-#K = " hash-#k .var
  62.     ." Hash-State = " hash-state .var
  63.     ." #Collisions = " hash-#collisions .var
  64.     ." FIND is " what's find >name id. cr
  65. ;
  66.  
  67. \ Compile Time Initialization
  68. 8 hash-#k !
  69.  
  70. \ Create table of prime pairs near 1000s
  71. CREATE PRIMEK-PAIRS
  72.         1 ,  1009 ,  2027 ,  2999 ,  4001 ,
  73.      5009 ,  6089 ,  6959 ,  8009 ,  8999 , 
  74.     10007 , 11069 , 12041 , 13001 , 14009 , 
  75.     15137 , 16061 , 17027 , 18041 , 19079 ,
  76.     20021 , 21011 , 22037 , 23027 , 24107 ,
  77.     25031 , 26111 , 27059 , 28097 , 29021 , 
  78.     30011 , 31079 , 32027 , 33071 , 34031 ,
  79.     35081 , 36011 , 37019 , 37991 ,
  80. 39 constant PRIMEK_MANY
  81.  
  82. : PRIMEK ( N -- P , lowest of nearest prime pair )
  83.     dup primek_many <
  84.     IF cells primek-pairs + @
  85.     ELSE ." Past Prime Pair Table!" cr
  86.         1000 * 1-
  87.     THEN
  88. ;
  89.  
  90. : HASH.FREE ( -- , free space for table )
  91.     hash-table-ptr @ ?dup
  92.     IF ( -- addr )
  93.        freeblock
  94.        hash-table-ptr off
  95.        hash-table-size off
  96.        hash-many off
  97.     THEN
  98. ;
  99.  
  100. : HASH.TERM  ( -- )
  101.     hash.off
  102.     hash.free
  103. ;
  104.  
  105. : $HASH.ABORT ( $error-message -- )
  106.     hash.term
  107.     $error
  108. ;
  109.  
  110. : HASH.ALLOC  ( #K -- error , allocate space for table )
  111.     hash.free
  112.     primek 2+
  113.     dup hash-table-size !  ( set max )
  114.     cells ( -- #bytes )
  115.     memf_clear swap allocblock ?dup ( -- addr , zeroed RAM)
  116.     IF hash-table-ptr ! false
  117.     ELSE true
  118.     THEN
  119. ;
  120.  
  121. \ Functions for generating Hash Keys.
  122. DEFER NAME>KEY   ( nfa -- key )
  123.  
  124. \ High level and simpler version.
  125. false .IF
  126. : NAME.4N+.HIGH   ( nfa -- key , add characters )
  127.     0 swap  ( sum )
  128.     dup 1+ swap c@ 31 and 0  ( -- 0 addr count 0 ) 
  129.     DO ( -- sum addr )
  130.         i over + c@  \  dup cr emit space .s ( get char )
  131.         rot cells + swap
  132.     LOOP drop abs
  133. ;
  134. .THEN
  135.  
  136. ASM NAME.4N+  ( nfa -- key , faster hash key generator )
  137. \ Register Usage
  138. \    D0 = Shift Count
  139. \    D1 = Number of characters left
  140. \    D2 = Pad for bytes
  141. \    D7 = running total
  142. \    A0 = Address of next char
  143.     MOVE.L        D2,-(A7)
  144.     MOVE.L        TOS,A0
  145.     ADD.L        ORG,A0   \ Calc absolute address
  146.     MOVEQ.L        #0,D7
  147.     MOVE.L        D7,D0
  148.     MOVE.L        D7,D2
  149.     MOVE.B        (A0)+,D1
  150.     ANDI.L        #$1F,D1
  151.     BEQ        2$
  152.     SUBQ.L        #1,D1    \ Adjust for DBRQ
  153.     MOVEQ.L        #2,D0    \ Size determines shift count!
  154.     CMP.W        #8,D1
  155.     BLT        1$
  156.     MOVEQ.L        #1,D0
  157. 1$:    ASL.L        D0,D7
  158.     MOVE.B        (A0)+,D2
  159.     ADD.L        D2,D7
  160.     DBRA.W        D1,1$
  161. 2$:    ANDI.L        #$FFFFFF,d7  \ clip result 0F!!
  162.     MOVE.L        (A7)+,D2
  163.     RTS
  164. END-CODE
  165.  
  166. : NAME+VOC>KEY   ( nfa -- key )
  167.     name.4n+
  168.     hash-voc-offset @ +
  169. ;
  170.  
  171. ' NAME+VOC>KEY is NAME>KEY
  172.  
  173. : KEY>HASH ( key -- hash# )
  174.     hash-table-size @ ( -- nfa max_#entries ) mod
  175. ;
  176.  
  177. : NAME>HASH  ( nfa -- hash# , convert name to number )
  178.     name>key key>hash
  179. ;
  180.  
  181. : HASH.CHECK  ( hash# -- hash# , check for overflow or underflow )
  182.     dup hash-table-size @ 1- 0 swap within? not
  183.     IF . " Hash# out of range!" $hash.abort
  184.     THEN
  185. ;
  186.  
  187. : HASH>ADDR ( hash# -- addr , calc addr in table )
  188.     hash.check cells
  189.     hash-table-ptr @ + ( allocated array base )
  190. ;
  191.  
  192. : HASH>NAME ( hash# -- nfa )
  193.     hash>addr @
  194. ;
  195.  
  196. false .IF
  197. : MATCH.NAMES.HIGH { nfa1 nfa2 | flag -- flag }
  198.     nfa1 c@ 31 and
  199.     nfa2 c@ 31 and =
  200.     IF  ( same length )
  201.         true -> flag
  202.         nfa1 nfa2 dup c@ 31 and 0
  203.         DO 1+ dup c@ >r
  204.            swap 1+ dup c@ r> -
  205.            IF false -> flag
  206.            THEN
  207.         LOOP 2drop flag
  208.     ELSE false
  209.     THEN
  210. ;
  211. .THEN
  212.  
  213. ASM MATCH.NAMES ( nfa0 nfa1 -- if_equal )
  214.     movem.l        d0-d2/a0-a1,-(a7)
  215.     move.l        (a6)+,a0
  216.     adda.l        org,a0
  217.     move.b        $0(a4,tos),d1    00001 , was "tos)+,d1"
  218.     move.b        (a0)+,d0
  219.     moveq.l        #$1f,d2
  220.     and.l        d2,d0
  221.     beq        2$
  222.     and.l        d2,d1
  223.     cmp.b        d0,d1
  224.     bne        2$
  225.  
  226.     addq.l        #1,tos
  227.     move.l        tos,a1        \ nfa1+1
  228.     adda.l        org,a1
  229.     subq.l        #1,d1
  230.  
  231. 1$:    cmpm.b        (a0)+,(a1)+
  232.     dbne.w        d1,1$
  233.     bne        2$
  234.     moveq.l        #$-1,tos
  235.     movem.l        (a7)+,d0-d2/a0-a1
  236.     rts
  237.  
  238. 2$:    moveq.l        #0,tos
  239.     movem.l        (a7)+,d0-d2/a0-a1
  240.     rts
  241. END-CODE
  242.  
  243. \ Return match or empty slot.
  244. false .IF
  245. : HASH.SEARCH { name table | key hash# incr modulus -- hash# flag }
  246.     name name>key dup -> key
  247.     table @ dup -> modulus  mod dup -> hash#
  248. \    ." Key = " key . ."  , hash# = " hash# . cr
  249. \    ." Modulus = " modulus . cr .s
  250.     table hash>name ?dup 
  251.     IF  name match.names
  252.         IF  true
  253.         ELSE key table @ 2- mod -> incr  ( calculate increment )
  254. \            ." incr = " incr . cr
  255.             ( scan for match or empty slot )
  256.             false modulus 0
  257.             DO  1 hash-#collisions +! 
  258.                 hash# incr + modulus mod   ( -- new_hash# )
  259.                 dup -> hash#
  260.                 table hash>name ?dup
  261.                 IF  name match.names
  262.                     IF drop true leave THEN
  263.                 ELSE leave
  264.                 THEN
  265.             LOOP
  266.         THEN
  267.     ELSE false
  268.     THEN
  269.     hash# swap
  270. ;
  271. .THEN
  272.  
  273. : INCNUMCOL ( -- )
  274.     hash-#collisions @ 1+ hash-#collisions !
  275. ;
  276.  
  277. ASM HASH.SEARCH.LL  ( array size name -- hash# flag )
  278. \ Register Usage
  279. \  D0 = key
  280. \  D1 = hash#
  281. \  D2 = modulus
  282. \  D3 = increment
  283. \  A0 = array base
  284. \  A1 = name
  285.     movem.l        d0-d3/a0-a1,-(a7)
  286. \ Get Key for Name
  287.         move.l        tos,-(a6)    \ DUP
  288.     callcfa        NAME>KEY  ( -- a s n key )
  289. \
  290. \ Gather parameters
  291.         move.l        tos,d0        \ key
  292.     move.l        (a6)+,a1    \ name  ( rel )
  293.     move.l        (a6)+,d2    \ modulus
  294.     move.l        (a6)+,a0    \ array
  295.     adda.l        org,a0        \ >abs
  296. \
  297. \ DO fast MOD to convert key>hash
  298.     move.l        d0,d1
  299.     divu        d2,d1        \ hash# = mod(key,modulus)
  300.         swap        d1
  301.     and.l        #$FFFF,D1
  302. \
  303. \ Lookup NFA in array
  304.     move.l        d1,d7        \ hash#,d7
  305.     asl.l        #2,d7        \ cell*
  306.     move.l        $0(a0,d7),d7    \ load name address
  307. \
  308. \ Check for match if name found.
  309.     BEQ        4$        \ skip if empty slot
  310.     move.l        a1,-(a6)    \ push name
  311.     callcfa        match.names
  312. \
  313. \ Return true if matched
  314.     tst.l        tos        \ result non zero?
  315.     BNE        4$        \ 
  316. \
  317. \ If it is not the right name, collision!
  318. \ Calculate increment and begin searching.
  319. \ Increment = MOD(KEY,SIZE-2)
  320.     move.l        d0,d3        \ copy KEY
  321. \ Use size for loop count
  322.     move.l        d2,d0
  323.     move.l        d2,d7        \ size
  324.     subq.l        #2,d7        \ 2-
  325.     divu        d7,d3        \ MOD
  326.     swap        d3
  327.     and.l        #$FFFF,D3
  328.     BNE        2$
  329.     moveq.l        #1,d3        \ 1 better than 0
  330. \
  331. 2$:    add.l        d3,d1        \ increment hash#
  332.     divu        d2,d1        \ SIZE MOD
  333.     swap        d1
  334.     and.l        #$FFFF,d1
  335. \
  336. \ Increment Collision Counter
  337.     callcfa        incnumcol
  338. \
  339. \ lookup name in new array location
  340.     move.l        d1,d7        \ new hash#
  341.     asl.l        #2,d7
  342.     move.l        $0(a0,d7),d7    \ load name address
  343. \
  344. \ check for match if NFA found
  345.     BEQ        3$        \ otherwise return 0
  346.     move.l        a1,-(a6)
  347.     callcfa        match.names
  348. \
  349. \ Keep looking if not a match
  350.     cmpi.l        #0,tos
  351.     DBNE.W        d0,2$
  352. \
  353.     moveq.l        #$-1,tos
  354.     bra        4$
  355. \ 
  356. 3$:    moveq.l        #0,tos
  357. \
  358. 4$:    move.l        d1,-(a6)
  359.     movem.l        (a7)+,d0-d3/a0-a1
  360.     rts
  361. END-CODE
  362.  
  363. : HASH.SEARCH ( name -- hash#matched true | hash#empty false )
  364.     >r hash-table-ptr @ hash-table-size @ r>
  365.     hash.search.ll
  366. ;
  367.  
  368. : HASH.FIND.NAME ( name --  nfa true | oldname false )
  369.     dup hash.search ( -- name hash# flag )
  370.     IF  nip hash>name true
  371.     ELSE drop false
  372.     THEN
  373. ;
  374.  
  375. : HASH.NEW.VOC ( voc-addr -- )
  376.    vlink>' >name \ dup id. cr
  377.    name.4n+ hash-voc-offset !   ( set voc offset )
  378. ;
  379.  
  380. : HASH.SEARCH.CONTEXT ( name --  nfa true | oldname false )
  381.     hash-found? off
  382.     hash-voc-offset @ >r
  383.     context maxvocs  cnt>range
  384.     DO  ( -- name )
  385.         i @  ?dup  0= ?LEAVE
  386.         hash.new.voc
  387.         dup hash.find.name
  388.         IF  ( -- name nfa )
  389.             nip hash-found? on leave
  390.         ELSE drop
  391.         THEN
  392.     CELL +LOOP
  393.     r> hash-voc-offset !
  394.     hash-found? @
  395. ;
  396.  
  397.   
  398. : HASH.SEARCH.VOCS ( name --  nfa true | oldname false )
  399.   hash.search.context dup 0=
  400.   IF
  401.      SEARCH-CURRENT @
  402.      IF
  403.         drop  CURRENT @ hash.new.voc
  404.         hash.find.name
  405.      THEN
  406.   THEN
  407. ;
  408.  
  409. : HASH.FIND ( name -- $name 0 | cfa_imm 1 | cfa -1 )
  410. \ Rehash if dictionary changed by modules, forget, etc.
  411.     hash-damaged @
  412.     IF rehash
  413.     THEN
  414.     hash.search.vocs
  415.     IF  dup name> swap immediate?
  416.         IF 1
  417.         ELSE -1
  418.         THEN
  419.     ELSE false
  420.     THEN
  421. ;
  422.  
  423.  
  424. : HASH.FULL? ( -- if_half_full , check table for overflow )
  425.     hash-table-size @ 2/
  426.     hash-many @ <
  427. ;
  428.  
  429. : HASH.(SMUDGE)  ( -- , replace latest entry )
  430.     hash-old-smudge
  431.     current @ hash.new.voc
  432.     latest hash.search
  433.     IF  hash-displaced @ swap
  434.         hash>addr !
  435.     ELSE drop
  436.     THEN
  437.     -1 hash-many +!
  438. \    >newline latest id. ."  smudged" cr
  439. ;
  440.  
  441. : HASH.(UNSMUDGE) ( -- , restore latest )
  442.     hash-old-unsmudge
  443.     current @ hash.new.voc
  444.     latest dup hash.search drop hash>addr !
  445.     1 hash-many +!
  446. \    >newline latest id. ."  unsmudged" cr
  447. ;
  448.  
  449. : HASH.ADD.NAME ( nfa hash# -- , force add and update counter )
  450.     hash>addr dup @ hash-displaced ! !  ( save previous occupant )
  451.     1 hash-many +!
  452. ;
  453.  
  454. : HASH.ADD.IFROOM  ( nfa hash# -- )
  455.     hash.full?
  456.     IF  ( -- n h )
  457.         2drop
  458.         hash-stopped on
  459. \        ." Hash table full!" cr
  460.     ELSE
  461.         hash.add.name
  462.     THEN
  463. ;
  464.  
  465. : HASH.ADD.IFNEW ( name -- )
  466.     dup hash.search ( -- name hash# flag )
  467.     IF 2drop
  468.     ELSE ( -- n h# )
  469.         hash.add.ifroom
  470.     THEN
  471. ;
  472.  
  473. : HASH.ADD.REHASH ( nfa -- , add to hash table during rehash)
  474.     dup c@ 31 and
  475.     IF  dup c@ $ 20 AND  ( hidden? )
  476.         hash-stopped @ OR
  477.         IF drop
  478.         ELSE hash.add.ifnew
  479.         THEN
  480.     ELSE drop cr ." HASH.ADD.REHASH Name field is zero!"
  481.     THEN
  482. ;
  483.  
  484. : HASH.CLEAR ( -- )
  485.     0 hash-many !
  486.     hash-table-ptr @
  487.     hash-table-size @ cells
  488.     0 fill
  489. ;
  490.     
  491. : <HASH.OFF> ( -- , turn hashing off )
  492.     hash-state @
  493.     IF 
  494.         what's hash-old-:create  is :create
  495.         what's hash-old-find     is find
  496.         what's hash-old-smudge   is smudge
  497.         what's hash-old-unsmudge is unsmudge
  498.         ' noop dup   is rehash   is hash.cold
  499.         hash-state off
  500.     THEN
  501. ;
  502. ' <hash.off> is hash.off
  503.  
  504. \ Check for vocabulary collisions.
  505. variable HASH-VOC-KEY
  506. variable HASH-VOC-LINK
  507. variable HASH-VOC-ERROR
  508.  
  509. : HASH.VOC.ERROR ( nfa -- , report collision )
  510.     >newline ." WARNING! - Possible HASHING conflict between " id.
  511.     ."  and " hash-voc-link @ vlink>' >name id. cr
  512.     hash-voc-error on
  513. ;
  514.  
  515. : HASH.TEST.VOC  ( -- , compare each vocab against one )
  516.     voc-link
  517.     BEGIN @ dup
  518.     WHILE dup hash-voc-link @ -
  519.         IF ( different vocabulary )
  520.             dup vlink>' >name dup name.4n+ hash-voc-key @ =
  521.             IF hash.voc.error
  522.             ELSE drop
  523.             THEN
  524.         THEN
  525.     REPEAT drop
  526. ;
  527.  
  528. : HASH.CHECK.VOCS  ( -- , check vocabularies for collision )
  529.     hash-voc-error off
  530.     voc-link
  531.     BEGIN @ dup
  532.     WHILE dup hash-voc-link !
  533.         dup vlink>' >name name.4n+ hash-voc-key !
  534.         hash.test.voc
  535.     REPEAT drop
  536.     hash-voc-error @
  537.     IF  ." Please rename the new vocabulary!"  7 emit cr
  538.     THEN
  539. ;
  540.  
  541. redef? off
  542. : VOCABULARY  ( <name> -- , check after defining )
  543.     vocabulary
  544.     hash.check.vocs
  545. ;
  546. redef? on
  547.  
  548. : <HASH.REALLOC> ( #K -- )
  549.     dup hash.alloc
  550.     IF drop " Could not allocate hash table!"
  551.        $hash.abort
  552.     ELSE  hash-#k !
  553.     THEN
  554. ;
  555.  
  556. : HASH.EXPAND  ( -- , increase size of hash table )
  557.     hash-#k @ 4 +
  558.     <hash.realloc>
  559. \    ." Hash table reallocated - successfully!" cr
  560. ;
  561.  
  562. : <REHASH>  ( -- , hash all vocs )
  563.     hash.check.vocs
  564.     ."   Rehashing..." flushemit
  565.     BEGIN
  566.         0 hash-stopped !
  567.         hash.clear
  568.         hash-#collisions off
  569.         ' hash.add.rehash is when-scanned
  570.         ' hash.new.voc is when-voc-scanned
  571.         scan-all-vocs
  572.         hash-stopped @
  573.     WHILE
  574.         hash.expand
  575.     REPEAT
  576.     hash-damaged off
  577.     hash-redef off
  578.     14 0 DO bsout @ emit space bsout @ emit
  579.     LOOP
  580.     flushemit
  581. ;
  582.  
  583. \ Substitute words.
  584. : HASH.ADD.NEW ( nfa -- )
  585.     hash.full?
  586.     IF  hash.expand
  587.         rehash
  588.     THEN
  589.     current @ hash.new.voc  ( do this after hash.expand )
  590.     dup hash.search
  591.     IF hash-redef on ( mark as redefined for fast forget )
  592.     THEN
  593.     hash.add.name
  594. ;
  595.  
  596. : HASH.(CREATE)  ( -- , add to hash table , overwrite existing.)
  597.     HASH-OLD-:CREATE
  598.     latest hash.add.new
  599. ;
  600.  
  601. : CHECK.TIB.END  ( nfa -- , set TIBEND if NUL string )
  602.     c@ 0= tibend !
  603. ;
  604.  
  605. : HASH.FORTH.FIND  ( nfa -- nfa 0 | cfa 1 | cfa -1 )
  606.     dup c@ dup 0= tibend !
  607.     31 and
  608.     IF hash.find
  609.     ELSE 0
  610.     THEN
  611. ;
  612.  
  613. : HASH.INIT ( -- )
  614.     hash-#k @ hash.alloc
  615.     IF  " No Room for hash Table!" $hash.abort
  616.     THEN
  617.     hash-voc-offset off
  618.     hash-state off
  619. ;
  620.  
  621. : <HASH.COLD>
  622.   cr ." Initializing HASHED Vocabulary Search..." flushemit cr
  623.   HASH.ON
  624. ;
  625.  
  626.  
  627. : <HASH.ON> ( -- , start using hashing )
  628.     hash-table-ptr @ 0=
  629.     IF hash.init 
  630.     THEN
  631.     hash-state @
  632.     IF \ ." Hashing already on!"
  633.     ELSE 
  634.         what's :create is hash-old-:create
  635.         what's find is hash-old-find
  636.         what's smudge is hash-old-smudge
  637.         what's unsmudge is hash-old-unsmudge
  638.         hash-state on
  639.     THEN
  640.     ' hash.(create)    is :create
  641.     ' hash.forth.find  is find
  642.     ' hash.(smudge)    is smudge
  643.     ' hash.(unsmudge)  is unsmudge
  644.     ' <rehash>         is rehash
  645.     ' <hash.cold>      is hash.cold
  646.     rehash
  647. ;
  648.  
  649. ' <hash.on> is hash.on
  650.  
  651. : HASH.REALLOC ( #K -- , reallocate different size)
  652.     hash.off
  653.     <hash.realloc>
  654.     hash.on
  655. ;
  656.  
  657. : SAVE-FORTH  ( -- , save in TERM state )
  658.   hash-state @ >r   hash.term  r@
  659.   IF
  660.      ' <hash.cold>
  661.   ELSE
  662.      ' noop
  663.   THEN
  664.   is hash.cold    save-forth  r@
  665.   IF
  666.      <hash.on>
  667.   ELSE
  668.      ' noop is hash.cold
  669.   THEN
  670.   rdrop
  671. ;
  672.  
  673. if.forgotten hash.term
  674.